home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / 4cmp22s.zip / HANOI.4TH < prev    next >
Text File  |  1994-10-30  |  4KB  |  118 lines
  1. \  Towers of Hanoi, by Peter Midnight  
  2. \   from FORTH DIMENSIONS, Vol II, No. 2, page 32 )
  3.  
  4. \  NOTICE: THIS SAMPLE PROGRAM IS FOR IBM-PC'S OR COMPATIBLES ONLY!
  5.  
  6. 256 MSDOS     
  7. INCLUDE FACIL1
  8. DECIMAL
  9. 2 0 IN/OUT  
  10. CODE CCHARS ( character+color count -- )
  11.      AX CX MOV  BL AL MOV  BH BL MOV   BH BH XOR  9 # AH MOV  16 INT  RET
  12.     END-CODE   
  13.  
  14. 12              CONSTANT NMAX
  15.                 VARIABLE N   ( formerly a constant )
  16.                 VARIABLE DELAY-TIME
  17. 0               CONSTANT FALSE
  18. 219  4 256 * +  CONSTANT COLOR ( ring )
  19. 219  12 256 * + CONSTANT BRIGHT ( bright ring )
  20. 186  2 256 * +  CONSTANT STAKE ( vertical bar )
  21. 176  1 256 * +  CONSTANT STAND ( flat base )
  22. DSEG            CREATE   RING  NMAX CELL+ ALLOT  
  23.  
  24. : 4DUP          3 PICK 3 PICK 3 PICK 3 PICK ;
  25.  
  26. 0 0 IN/OUT 
  27. : SLOWER  DELAY-TIME @  0 DO LOOP ;
  28.  
  29. 1 1 IN/OUT 
  30. : POS           ( location pos -> coordinate )
  31.                 N @ 2* 1+ * N @ + ;
  32.  
  33. : DISPLAY       ( size pos line color --- )
  34.             2 PICK 4 PICK - 2 PICK AT-XY
  35.             OVER 3 <  OVER BL <> OR
  36.               IF  -ROT 2DROP SWAP 2* 1+ CCHARS ELSE
  37.                   DUP 4 PICK CCHARS
  38.                   2 PICK 2 PICK AT-XY  STAKE 1 CCHARS
  39.                   -ROT SWAP 1+ SWAP AT-XY  SWAP CCHARS THEN ;
  40.  
  41. 2 1 IN/OUT 
  42. : PRESENCE      ( tower ring presence -> boolean )
  43.                 RING + C@ = ;
  44.  
  45. : LINE          ( tower line -> display-line-of-top )
  46.                 4 SWAP N @ 0 
  47.                 DO DUP I PRESENCE 0= IF SWAP 1+ SWAP THEN LOOP 
  48.                 DROP ;
  49.  
  50. : RAISE         ( size tower --- )
  51.                 DUP POS SWAP LINE 2 SWAP 
  52.                 DO 2DUP I BL DISPLAY 2DUP I 1- BRIGHT DISPLAY SLOWER -1 +LOOP 
  53.                 2DROP ;
  54.  
  55. : LOWER         ( size tower --- )
  56.                 DUP POS SWAP LINE DUP >R 1+ 2 
  57.                 DO 2DUP I 1- BL DISPLAY 2DUP I BRIGHT DISPLAY SLOWER LOOP  
  58.                 R> COLOR DISPLAY  ;   
  59.  
  60. : MOVELEFT      ( size source.tower destiny.tower --- )
  61.                 POS  SWAP POS 1- 
  62.                 DO DUP I 1+ 1 BL DISPLAY DUP I 1 BRIGHT DISPLAY SLOWER -1 +LOOP 
  63.                 DROP ;
  64.  
  65. : MOVERIGHT     ( size source.tower destiny.tower --- )
  66.                 POS 1+ SWAP POS 1+ 
  67.                 DO DUP I 1- 1 BL DISPLAY DUP I 1 BRIGHT DISPLAY SLOWER LOOP 
  68.                 DROP ;
  69.  
  70. : TRAVERSE      ( size source.tower destiny.tower --- )
  71.                 2DUP > IF MOVELEFT ELSE MOVERIGHT THEN ;
  72.  
  73. : MOVE          ( size source.tower destiny.tower --- )
  74.                 KEY? IF 0 N @ 4 + AT-XY BYE THEN
  75.                 -ROT 2DUP RAISE 
  76.                 >R 2DUP R> ROT TRAVERSE
  77.                 2DUP RING + 1- C! SWAP LOWER ;
  78.  
  79. : MULTIMOV      ( size source destiny spare --- )
  80.                 3 PICK 1 = IF DROP MOVE ELSE
  81.                 >R >R SWAP 1- SWAP R> R> 4DUP SWAP MULTIMOV
  82.                 4DUP DROP ROT 1+ -ROT MOVE
  83.                 -ROT SWAP MULTIMOV THEN ;
  84.  
  85. : MAKETOWER     ( tower --- )  POS 4 N @ + 3
  86.                 DO DUP I AT-XY STAKE 1 CCHARS LOOP 
  87.                 DROP ;
  88.  
  89. : MAKEBASE      ( no arguments ) 0 N  @  4 + AT-XY
  90.                 STAND N @ 6 * 3 + CCHARS ;
  91.  
  92. : MAKERING      ( tower size --- )
  93.                 2DUP RING + 1- C! SWAP LOWER ;
  94.  
  95. : SETUP         ( no arguments ) 
  96.                 PAGE  N @ 1+ 0 DO 1 RING I + C! LOOP 
  97.                 3 0 DO I MAKETOWER LOOP 
  98.                 MAKEBASE 
  99.                 1 N @ DO 0 I MAKERING -1 +LOOP ;
  100.  
  101. : TOWERS        ( quantity --- )
  102.                 1 MAX NMAX MIN N !
  103.                 SETUP N @ 2 0 1
  104.                 BEGIN
  105.                   OVER POS N @ 4 + AT-XY N @ 0
  106.                   DO   7 EMIT 200 MS LOOP
  107.                   ROT 4DUP MULTIMOV
  108.                   FALSE
  109.                 UNTIL ;
  110.  
  111. : MAIN CR ." DELAY TIME? "  #IN 1 MAX DELAY-TIME !
  112.        CR ." HOW MANY RINGS? "  #IN TOWERS ;
  113.  
  114. INCLUDE FACIL2
  115. INCLUDE FORTHLIB
  116. END
  117.  
  118.